module Hscm.Value where
import Parsec (ParseError)
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Except
import Data.IORef
import System.IO


{-
    ====== Hscm Value ==========
-}
data HscmValue 
    = Symbol String -- var name
    | List [HscmValue] -- (1 2 3)
    | DottedList [HscmValue] HscmValue -- (1 2 . 3) ==> (1 2) 3
    | Integer Integer -- 12
    | Double Double -- 2.3 
    | String String -- "str"
    | Bool Bool -- #f #t
    | Lambda { params:: [String], body:: HscmValue, envRef:: HscmEnvRef }
    | PrimitiveProc ([HscmValue] -> HscmResult HscmValue)
    | IOPrimitiveProc ([HscmValue] -> HscmIOResult HscmValue)
    | Port Handle


instance Show HscmValue where
    show = reprValue


reprValue :: HscmValue -> String
reprValue (String contents) = "\"" ++ contents ++ "\""
reprValue (Symbol name) = name
reprValue (Integer contents) = show contents
reprValue (Double value) = show value
reprValue (Bool True) = "#t"
reprValue (Bool False) = "#f"
reprValue (List contents) = "(" ++ unwordsReprList contents ++ ")"
reprValue (DottedList head tail) = "(" ++ unwordsReprList head ++ " . " ++ strValue tail ++ ")"
reprValue (Lambda params body env) = "(lambda (" ++ unwords (map show params) ++ ") ...)"
reprValue (PrimitiveProc _) = "<primitive proc>"
reprValue (IOPrimitiveProc _) = "<IO primitive proc>"
reprValue (Port _) = "<IO port>"

unwordsReprList :: [HscmValue] -> String
unwordsReprList = unwords . map reprValue


strValue :: HscmValue -> String
strValue (String contents) = contents
strValue (Symbol name) = name
strValue (Integer contents) = show contents
strValue (Double value) = show value
strValue (Bool True) = "#t"
strValue (Bool False) = "#f"
strValue (List contents) = "(" ++ unwordsStrList contents ++ ")"
strValue (DottedList head tail) = "(" ++ unwordsStrList head ++ " . " ++ strValue tail ++ ")"
strValue (Lambda params body env) = "(lambda (" ++ unwords (map show params) ++ ") ...)"
strValue (PrimitiveProc _) = "<primitive proc>"
strValue (IOPrimitiveProc _) = "<IO primitive proc>"
strValue (Port _) = "<IO port>"

unwordsStrList :: [HscmValue] -> String
unwordsStrList = unwords . map strValue


instance Eq HscmValue where
    (String s1) == (String s2) = s1 == s2
    (Symbol n1) == (Symbol n2) = n1 == n2
    (Integer n1) == (Integer n2) = n1 == n2
    (Double n1) == (Double n2) = n1 == n2
    (Bool   b1) == (Bool   b2) = b1 == b2
    (List   l1) == (List   l2) = all (\(v1, v2) -> v1 == v2) $ zip l1 l2 
    (DottedList head1 tail1) == (DottedList head2 tail2) 
        = ( all (\(v1, v2) -> v1 == v2) $ zip head1 head2 ) && tail1 == tail2

    _ == _ = False


{-
    ====== Hscm Env ======
-}

type VarMap = Map.Map String HscmValue
data HscmEnv = HscmEnv { vars :: VarMap, parent :: Maybe HscmEnvRef } 
type HscmEnvRef = IORef (HscmEnv)


emptyVarMap :: VarMap
emptyVarMap = Map.empty


newArgVarMap :: [String] -> [HscmValue] -> VarMap
newArgVarMap params args = foldl updateVars emptyVarMap (zip params args) 
    where
        updateVars :: VarMap -> (String, HscmValue) -> VarMap
        updateVars lastEnv (param, arg) = Map.insert param arg lastEnv 


insertVar :: String -> HscmValue -> HscmEnv -> HscmEnv
insertVar name value env = HscmEnv newVars (parent env)
    where
        newVars = Map.insert name value (vars env)


newEnv :: VarMap -> HscmEnvRef -> HscmEnv
newEnv varMap parentEnvRef = HscmEnv varMap (Just parentEnvRef) 


noVarEnv :: HscmEnvRef -> HscmEnv
noVarEnv parentEnvRef = HscmEnv emptyVarMap (Just parentEnvRef) 


defineVarInEnvRef :: HscmEnvRef -> String -> HscmValue -> HscmIOResult ()
defineVarInEnvRef envRef name value = do
    env <- liftIO $ readIORef envRef
    case Map.lookup name (vars env) of
        -- Already exit var, can't define!
        Just _  -> throwError $ Redefine name
        -- No `name` exit
        Nothing -> do
            -- Modify envRef!
            liftIO $ modifyIORef envRef (insertVar name value)
            return ()


setVarInEnvRef :: HscmEnvRef -> String -> HscmValue -> HscmIOResult ()
setVarInEnvRef envRef name value = do
    env <- liftIO $ readIORef envRef
    case Map.lookup name (vars env) of
        -- Exit var, try to set new value
        Just _  -> do
            liftIO $ modifyIORef envRef (insertVar name value)
            return ()
        -- No exit var
        Nothing -> case (parent env) of 
            Just parentEnvRef -> setVarInEnvRef parentEnvRef name value
            -- No parent env
            Nothing           -> throwError $ UnboundVar "Setting an unbound variable" name


getVarInEnvRef :: HscmEnvRef -> String -> HscmIOResult HscmValue
getVarInEnvRef envRef name = do
    env <- liftIO $ readIORef envRef
    case Map.lookup name (vars env) of
        -- Find varname in current env
        Just value -> return value
        -- Try find in parent
        Nothing    -> case (parent env) of 
            Just parentEnvRef -> getVarInEnvRef parentEnvRef name
            Nothing           -> throwError $ UnboundVar "Getting an unbound variable" name


{-
    Hscm Error
-}
type HscmIOResult = ExceptT HscmError IO
type HscmResult = Either HscmError


resultToIOResult :: HscmResult a -> HscmIOResult a
resultToIOResult (Left err)  = throwError err
resultToIOResult (Right val) = return val

trapError action = catchError action (return . show)


data HscmError
    = NumArgs Int [HscmValue]
    | TypeMismatch String HscmValue
    | Parse ParseError
    | Evaluate String
    | BadSpecialForm String HscmValue
    | NotFunction String String
    | UnboundVar String String
    | Redefine String
    | Default String
    deriving (Eq)


showError :: HscmError -> String
showError (UnboundVar message varname)  
    = message ++ ": " ++ varname
showError (Redefine varname)
    = "Redefine var '" ++ varname ++ "'"
showError (BadSpecialForm message form) 
    = message ++ ": " ++ show form
showError (NotFunction message func)    
    = message ++ ": " ++ show func
showError (NumArgs expected found)      
    = "Expected " ++ show expected ++ " args; found values " ++ unwordsStrList found
showError (TypeMismatch expected found) 
    = "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parse parseErr)            
    = "Parse error at " ++ show parseErr
showError (Evaluate message)
    = "Evaluate error: " ++ message


instance Show HscmError where 
    show = showError